home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 21 / Cream of the Crop 21 (Terry Blount) (October 1996).iso / program / slix0987.zip / DEGIF6.ZIP / DEGIF6.BAS
BASIC Source File  |  1996-05-17  |  10KB  |  290 lines
  1. '
  2. 'DEGIF6.BAS - No frills GIF decoder for the VGA's 320x200x256 mode.
  3. 'By Rich Geldreich 1993 (Public domain, use as you wish.)
  4. 'This version should properly decode all LZW encoded images in
  5. 'GIF image files. I've finally added GIF89a and local colormap
  6. 'support, so it more closely follows the GIF specification. It
  7. 'still doesn't support the entire GIF89a specification, but it'll
  8. 'show most GIF files fine.
  9. 'The GIF decoding speed of this program isn't great, but I'd say
  10. 'for an all QB/PDS decoder it's not bad!
  11. 'Note: This program does not stop decoding the GIF image after the
  12. 'rest of the scanlines become invisible! This happens with images
  13. 'larger than the 320x200 screen. So if the program seems to be
  14. 'just sitting there, accessing your hard disk, don't worry...
  15. 'It'll beep when it's done.
  16. DEFINT A-Z
  17. 'Prefix() and Suffix() hold the LZW phrase dictionary.
  18. 'OutStack() is used as a decoding stack.
  19. 'ShiftOut() as a power of two table used to quickly retrieve the LZW
  20. 'multibit codes.
  21. DIM Prefix(4095), Suffix(4095), OutStack(4095), ShiftOut(8)
  22.  
  23. 'The following line is for the QB environment(slow).
  24. DIM YBase AS LONG, Powersof2(11) AS LONG, WorkCode AS LONG
  25. 'For a little more speed, unremark the next line and remark the one
  26. 'above, before you compile... You'll get an overflow error if the
  27. 'following line is used in the QB environment, so change it back.
  28. 'DIM YBase AS INTEGER, Powersof2(11) AS INTEGER, WorkCode AS INTEGER
  29.  
  30. 'Precalculate power of two tables for fast shifts.
  31. FOR A = 0 TO 8: ShiftOut(8 - A) = 2 ^ A: NEXT
  32. FOR A = 0 TO 11: Powersof2(A) = 2 ^ A: NEXT
  33.  
  34. 'Get GIF filename.
  35. A$ = COMMAND$: IF A$ = "" THEN INPUT "GIF file"; A$: IF A$ = "" THEN END
  36. 'Add GIF extension if the given filename doesn't have one.
  37. FOR A = LEN(A$) TO 1 STEP -1
  38.     SELECT CASE MID$(A$, A, 1)
  39.     CASE "\", ":": EXIT FOR
  40.     CASE ".": Extension = -1: EXIT FOR
  41.     END SELECT
  42. NEXT
  43. IF Extension = 0 THEN A$ = A$ + ".GIF"
  44.  
  45. 'Open file for input so QB stops with an error if it doesn't exist.
  46. OPEN A$ FOR INPUT AS #1: CLOSE #1
  47. OPEN A$ FOR BINARY AS #1
  48.  
  49. 'Check to see if GIF file. Ignore GIF version number.
  50. A$ = "      ": GET #1, , A$
  51. IF LEFT$(A$, 3) <> "GIF" THEN PRINT "Not a GIF file.": END
  52.  
  53. 'Get logical screen's X and Y resolution.
  54. GET #1, , TotalX: GET #1, , TotalY: GOSUB GetByte
  55. 'Calculate number of colors and find out if a global palette exists.
  56. NumColors = 2 ^ ((A AND 7) + 1): NoPalette = (A AND 128) = 0
  57. 'Retrieve background color.
  58. GOSUB GetByte: Background = A
  59.  
  60. 'Get aspect ratio and ignore it.
  61. GOSUB GetByte
  62.  
  63. 'Retrieve global palette if it exists.
  64. IF NoPalette = 0 THEN P$ = SPACE$(NumColors * 3): GET #1, , P$
  65.  
  66. DO 'Image decode loop
  67.  
  68. 'Skip by any GIF extensions.
  69. '(With a few modifications this code could also fetch comments.)
  70. DO
  71.     'Skip by any zeros at end of image (why must I do this? the
  72.     'GIF spec never mentioned it)
  73.     DO
  74.         IF EOF(1) THEN GOTO AllDone 'if at end of file, exit
  75.         GOSUB GetByte
  76.     LOOP WHILE A = 0           'loop while byte fetched is zero
  77.  
  78.     SELECT CASE A
  79.     CASE 44  'We've found an image descriptor!
  80.         EXIT DO
  81.     CASE 59  'GIF trailer, stop decoding.
  82.         GOTO AllDone
  83.     CASE IS <> 33
  84.         PRINT "Unknown GIF extension type.": END
  85.     END SELECT
  86.     'Skip by blocked extension data.
  87.     GOSUB GetByte
  88.     DO: GOSUB GetByte: A$ = SPACE$(A): GET #1, , A$: LOOP UNTIL A = 0
  89. LOOP
  90. 'Get image's start coordinates and size.
  91. GET #1, , XStart: GET #1, , YStart: GET #1, , XLength: GET #1, , YLength
  92. XEnd = XStart + XLength: YEnd = YStart + YLength
  93.  
  94. 'Check for local colormap, and fetch it if it exists.
  95. GOSUB GetByte
  96. IF (A AND 128) THEN
  97.     NoPalette = 0
  98.     NumColors = 2 ^ ((A AND 7) + 1)
  99.     P$ = SPACE$(NumColors * 3): GET #1, , P$
  100. END IF
  101.  
  102. 'Check for interlaced image.
  103. Interlaced = (A AND 64) > 0: PassNumber = 0: PassStep = 8
  104.  
  105. 'Get LZW starting code size.
  106. GOSUB GetByte
  107.  
  108. 'Calculate clear code, end of stream code, and first free LZW code.
  109. ClearCode = 2 ^ A
  110. EOSCode = ClearCode + 1
  111. FirstCode = ClearCode + 2: NextCode = FirstCode
  112. StartCodeSize = A + 1: CodeSize = StartCodeSize
  113.  
  114. 'Find maximum code for the current code size.
  115. StartMaxCode = 2 ^ (A + 1) - 1: MaxCode = StartMaxCode
  116.  
  117. BitsIn = 0: BlockSize = 0: BlockPointer = 1
  118.  
  119. X = XStart: y = YStart: YBase = y * 320&
  120.  
  121. 'Set screen 13 in not set yet.
  122. IF FirstTime = 0 THEN
  123.     'Go to VGA mode 13 (320x200x256).
  124.     SCREEN 13: DEF SEG = &HA000
  125. END IF
  126.  
  127. 'Set palette, if there was one.
  128. IF NoPalette = 0 THEN
  129.     'Use OUTs for speed.
  130.     OUT &H3C8, 0
  131.     FOR A = 1 TO NumColors * 3: OUT &H3C9, ASC(MID$(P$, A, 1)) \ 4: NEXT
  132.     'Save palette of image to disk.
  133.     'OPEN "pal." FOR BINARY AS #2: PUT #2, , P$: CLOSE #2
  134. END IF
  135.  
  136. IF FirstTime = 0 THEN
  137.   'Clear entire screen to background color. This isn't
  138.   'done until the image's palette is set, to avoid flicker
  139.   'on some GIFs.
  140.     LINE (0, 0)-(319, 199), Background, BF
  141.     FirstTime = -1
  142. END IF
  143.  
  144. 'Decode LZW data stream to screen.
  145. DO
  146.     'Retrieve one LZW code.
  147.     GOSUB GetCode
  148.     'Is it an end of stream code?
  149.     IF Code <> EOSCode THEN
  150.         'Is it a clear code? (The clear code resets the sliding
  151.         'dictionary - it *should* be the first LZW code present in
  152.         'the data stream.)
  153.         IF Code = ClearCode THEN
  154.             NextCode = FirstCode
  155.             CodeSize = StartCodeSize
  156.             MaxCode = StartMaxCode
  157.             DO: GOSUB GetCode: LOOP WHILE Code = ClearCode
  158.             IF Code = EOSCode THEN GOTO ImageDone
  159.             LastCode = Code: LastPixel = Code
  160.             IF X < 320 AND y < 200 THEN POKE X + YBase, LastPixel
  161.             X = X + 1: IF X = XEnd THEN GOSUB NextScanLine
  162.         ELSE
  163.             CurCode = Code: StackPointer = 0
  164.  
  165.             'Have we entered this code into the dictionary yet?
  166.             IF Code >= NextCode THEN
  167.                 IF Code > NextCode THEN GOTO AllDone 'Bad GIF if this happens.
  168.                'mimick last code if we haven't entered the requested
  169.                'code into the dictionary yet
  170.                 CurCode = LastCode
  171.                 OutStack(StackPointer) = LastPixel
  172.                 StackPointer = StackPointer + 1
  173.             END IF
  174.  
  175.             'Recursively get each character of the string.
  176.             'Since we get the characters in reverse, "push" them
  177.             'onto a stack so we can "pop" them off later.
  178.             'Hint: There is another, much faster way to accomplish
  179.             'this that doesn't involve a decoding stack at all...
  180.             DO WHILE CurCode >= FirstCode
  181.                 OutStack(StackPointer) = Suffix(CurCode)
  182.                 StackPointer = StackPointer + 1
  183.                 CurCode = Prefix(CurCode)
  184.             LOOP
  185.  
  186.             LastPixel = CurCode
  187.             IF X < 320 AND y < 200 THEN POKE X + YBase, LastPixel
  188.             X = X + 1: IF X = XEnd THEN GOSUB NextScanLine
  189.  
  190.             '"Pop" each character onto the display.
  191.             FOR A = StackPointer - 1 TO 0 STEP -1
  192.                 IF X < 320 AND y < 200 THEN POKE X + YBase, OutStack(A)
  193.                 X = X + 1: IF X = XEnd THEN GOSUB NextScanLine
  194.             NEXT
  195.  
  196.             'Can we put this new string into our dictionary? (Some GIF
  197.             'encoders will wait a bit when the dictionary is full
  198.             'before sending a clear code- this increases compression
  199.             'because the dictionary's contents are thrown away less
  200.             'often.)
  201.             IF NextCode < 4096 THEN
  202.                 'Store new string in the dictionary for later use.
  203.                 Prefix(NextCode) = LastCode
  204.                 Suffix(NextCode) = LastPixel
  205.                 NextCode = NextCode + 1
  206.                 'Time to increase the LZW code size?
  207.                 IF (NextCode > MaxCode) AND (CodeSize < 12) THEN
  208.                     CodeSize = CodeSize + 1
  209.                     MaxCode = MaxCode * 2 + 1
  210.                 END IF
  211.             END IF
  212.             LastCode = Code
  213.         END IF
  214.     END IF
  215. LOOP UNTIL Code = EOSCode
  216. ImageDone:
  217.  
  218. LOOP
  219.  
  220. AllDone:
  221.  
  222. 'Save image and palette to BSAVE file.
  223. 'DEF SEG = &HA000
  224. 'O